COMMENT ⊗   VALID 00007 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	entry
C00004 00003	!	compute_func,uncompute_func,error,ggtoken
C00007 00004	!	MAKE_CODE, EVAL_CODE
C00020 00005	!	procedures exp,term,factor
C00029 00006	!	function evaluation routines:	EVAL, REDUCE
C00032 00007	!	GTEXPR, FNEXPR
C00034 ENDMK
C⊗;
entry;
BEGIN "GTEXPR"
DEFINE $EXPR=TRUE ;

	REQUIRE "HEADER.SAI" SOURCE_FILE;

PRESET_WITH NULL,"SCALAR","VECTOR","ROT","TRANS","FRAME","MACRO","FUNCTION";
INTERNAL STRING ARRAY $DTYPE[0:7];


define token_class = [tokenclass],token_index=[tokenindex];

INTERNAL RPTR (EXPR) PROCEDURE MK_EXPR(RPTR(SCALAR,VECTOR,ROT,TRANS,FRAME,EXPR,FUNCTION,SYMBOL) PTR;
		INTEGER TYPE; RPTR(EXPR) EX(NULL_RECORD));
	α RPTR(EXPR)X;		X←NEW_RECORD(EXPR);
	EXPR:PTR[X]←PTR;	EXPR:TYPE[X]←TYPE;
	EXPR:NEXT[X]←EX;
	RETURN(X);
	β;



INTERNAL RPTR(TREE)PROCEDURE NWTREE(RPTR(SCALAR, VECTOR,ROT,TRANS,FRAME,SYMBOL) R; INTEGER T);
	α RPTR(TREE) K; K←NEW_RECORD(TREE);
	TREE:DATA[K]←R; TREE:DTYPE[K]←T; RETURN(K); β;


!	compute_func,uncompute_func,error,ggtoken;



STRING  EXPRESSION_STRING;

RPTR(EXPR) SYMSTACKTOP;
rptr(function) fn_cur;

RPTR(EXPR)PROCEDURE PUSHSYMSTACK(RPTR(SYMBOL) S;INTEGER N);
	BEGIN
	RPTR(EXPR)SY;
	SY←SYMSTACKTOP;
	WHILE SY≠NULL_RECORD AND EXPR:PTR[SY]≠S DO SY←EXPR:NEXT[SY];
	IF SY=NULL_RECORD THEN 
		BEGIN SY←MK_EXPR(S,N,SYMSTACKTOP);
		SYMSTACKTOP←SY;
		END;
	RETURN(SY);
	END;


INTEGER PROCEDURE COMPUTE_FUNC(INTEGER I1,I2,I3(0),I4(0),I5(0));
	RETURN(((((I1*#DTYPE +I2)*#DTYPE + I3)*#DTYPE) + I4)*#DTYPE +I5);

DEFINE MCOMPUTE_FUNC(I1,I2,I3,I4,I5) =
	[(((((I1*#DTYPE +I2)*#DTYPE + I3)*#DTYPE) + I4)*#DTYPE +I5)];

INTEGER PROCEDURE UNCOMPUTE_FUNC(INTEGER I1,I2);
	α INTEGER I;
		CASE I2 OF
			α	[1]	I←I1 DIV #DTYPE↑4;
				[2]	I←(I1 DIV #DTYPE↑3)MOD #DTYPE;
				[3]	I←(I1 DIV #DTYPE↑2) MOD #DTYPE;
				[4]	I←(I1 DIV #DTYPE) MOD #DTYPE;
				[5]	I←I1 MOD #DTYPE;
				ELSE ERROR("WRONG FIELD IN UNCOMPPUTE_FUNC PARSER ERROR")
			β;
	RETURN(I);
	β;

define token_ptr=[tokenptr];


PROCEDURE GGTOKEN(BOOLEAN FLAG(TRUE));
α	IF STOKEN THEN GTOKEN(FLAG)
		ELSE BEGIN GTOKEN(FLAG);
			EXPRESSION_STRING←EXPRESSION_STRING&" "&TOKEN; END;
	IF #TOKEN=INT_TYPE OR #TOKEN=REAL_TYPE THEN
			α INTEGER I; 
			TOKENINDEX←#SC;
			TOKEN_PTR←SMAKE(REALSCAN(TOKEN,I));
			β
	ELSE IF #TOKEN=OPERATOR_TYPE THEN DECSTR(TOKEN);
β;

PROCEDURE ECOPY(RPTR(EXPR)R1,R2);
α	EXPR:PTR[R1]←EXPR:PTR[R2];
	EXPR:TYPE[R1]←EXPR:TYPE[R2];
	EXPR:NEXT[R1]←EXPR:NEXT[R2];
β;
!	MAKE_CODE, EVAL_CODE;

REQUIRE "⊂⊃⊂⊃" REPLACE_DELIMITERS;

	! returns the index of the array A whose element has value val, 0 if
		no such element ;

INTEGER PROCEDURE MATINX(INTEGER VAL; INTEGER ARRAY A; INTEGER LB,UB);
	α INTEGER L,M,U;
	L←LB; U←UB;
	DO α M←(U+L)/2;
		IF A[M]=VAL THEN RETURN(M)
			ELSE IF A[M]>VAL THEN U←M-1
			ELSE L←M+1;
	   β UNTIL L>U;
	RETURN(0);
	β;




DEFINE OPCODE = ⊂
! xx( operator, operator code, arg1 type, arg2 type, result type, routine to call) ;
XX("*",	TIMES_X,	#SC,	#SC,	#SC,	⊂OPSCAL(#1,#2,"*")⊃)
XX("*",	TIMES_X,	#SC,	#VT,	#VT,	⊂OPSCVT(#1,#2,"*")⊃)
XX("*",	TIMES_X,	#VT,	#SC,	#VT,	⊂OPSCVT(#2,#1,"*")⊃)
XX("*", TIMES_X,	#VT,	#VT,	#VT,	⊂OPVET(#1,#2,"*")⊃)
XX("*",	TIMES_X,	#RT,	#VT,	#VT,	⊂OPRTVT(#1,#2)⊃)
XX("*",	TIMES_X,	#RT,	#RT,	#RT,	⊂OPRTRT(#1,#2)⊃)
XX("*",	TIMES_X,	#TR,	#VT,	#VT,	⊂OPTRVT(#1,#2)⊃)
XX("*",	TIMES_X,	#TR,	#TR,	#TR,	⊂OPTRTR(#1,#2)⊃)
XX("*",	TIMES_X,	#TR,	#FR,	#FR,	⊂OPTRFR(#1,#2)⊃)
XX("*",	TIMES_X,	#FR,	#TR,	#FR,	⊂OPFRTR(#1,#2)⊃)
XX("*",	TIMES_X,	#FR,	#FR,	#FR,	⊂OPFR(#1,#2)⊃)

XX(".",	DOT_X,		#VT,	#VT,	#SC,	⊂OPDOT(#1,#2)⊃)

XX("REL",	REL_X,	#VT,	#FR,	#VT,	⊂OPVTFR(#2,#1)⊃)

XX("→",	BACKARROW_X,	#FR,	#FR,	#TR,	⊂OPFRFR(#1,#2)⊃)

XX("/",	DIVIDE_X,	#SC,	#SC,	#SC,	⊂OPSCAL(#1,#2,"/")⊃)
XX("/",	DIVIDE_X,	#VT,	#SC,	#VT,	⊂OPSCVT(#2,#1,"/")⊃)
XX("MIN",MIN_X,		#SC,	#SC,	#SC,	⊂OPSCAL(#1,#2,"MIN")⊃)
XX("MAX",MAX_X,		#SC,	#SC,	#SC,	⊂OPSCAL(#1,#2,"MAX")⊃)
XX("MOD",MOD_X,		#SC,	#SC,	#SC,	⊂OPSCAL(#1,#2,"MOD")⊃)
XX("DIV",DIV_X,		#SC,	#SC,	#SC,	⊂OPSCAL(#1,#2,"DIV")⊃)

XX("+",	PLUS_X,		#SC,	0,	#SC,	⊂OPSCAL(#1,0.,"+")⊃)
XX("+",	PLUS_X,		#SC,	#SC,	#SC,	⊂OPSCAL(#1,#2,"+")⊃)
XX("+",	PLUS_X,		#VT,	0,	#VT,	⊂OPVET(#1,NEW_RECORD(VECTOR),"+")⊃)
XX("+",	PLUS_X,		#VT,	#VT,	#VT,	⊂OPVET(#1,#2,"+")⊃)
XX("+",	PLUS_X,		#VT,	#FR,	#FR,	⊂OPFRVT(#1,#2,"+")⊃)
XX("+",	PLUS_X,		#FR,	#VT,	#FR,	⊂OPFRVT(#2,#1,"+")⊃)

XX("-",	MINUS_X,	#SC,	0,	#SC,	⊂OPSCAL(0.,#1,"-")⊃)
XX("-",	MINUS_X,	#SC,	#SC,	#SC,	⊂OPSCAL(#1,#2,"-")⊃)
XX("-",	MINUS_X,	#VT,	0,	#VT,	⊂OPVET(NEW_RECORD(VECTOR),#1,"-")⊃)
XX("-",	MINUS_X,	#VT,	#VT,	#VT,	⊂OPVET(#1,#2,"-")⊃)
XX("-",	MINUS_X,	#FR,	#VT,	#FR,	⊂OPFRVT(#2,#1,"-")⊃)
! XX("WRT",	WRT_X,						) ;



! yy(operator,	operator code,	fn to call, result type, #of args, arg types) ;
YY("POS",	POS_X,		TPOS,	#VT,	1,	#TR,	0,	0)
YY("POS",	POS_X,		FPOS,	#VT,	1,	#FR,	0,	0)
YY("UNIT",	UNIT_X,		NORMVT,	#VT,	1,	#VT,	0,	0)
! YY("AXIS",	AXIS_X,		FAXIS,	#VT,	1,	#RT,	0,	0) ;
! YY("ORIENT",	ORIENT_X,	FORIENT,#RT,	1,	#TR,	0,	0) ;
! YY("REL",	REL_X,		RELVT,	#VT,	2,	#VT,	#FR,	0) ;
! YY("REL",	REL_X,		RELFR,	#FR,	2,	#FR,	#TR,	0) ;
! YY("WRT",	WRT_X,		WRTVT,	#VT,	2,	#VT,	#FR,	0) ;
YY("ORIENT",	ORIENT_X,	FORIEN,	#RT,	1,	#FR,	0,	0)
YY("CONSTRUCT",	CONSTRUCT_X,	CONSV,	#FR,	3,	#VT,	#VT,	#VT)
YY("CONSTRUCT",	CONSTRUCT_X,	CONSF,	#FR,	3,	#FR,	#FR,	#FR)
YY("FRAME",	FRAME_X,	FMAKE,	#FR,	2,	#RT,	#VT,	0) 
YY("VECTOR",	VECTOR_X,	VMAKE,	#VT,	3,	#SC,	#SC,	#SC)
YY("TRANS",	TRANS_X,	TMAKE,	#TR,	2,	#RT,	#VT,	0)
YY("MAGNITUDE",	MAGNITUDE_X,	SMOD,	#SC,	1,	#SC,	0,	0)
YY("MAGNITUDE",	MAGNITUDE_X,	VMOD,	#SC,	1,	#VT,	0,	0)
! YY("MAGNITUDE",	MAGNITUDE_X,	RMOD,	#SC,	1,	#RT,	0,	0) ;
YY("IMPLICIT",	IMPLICIT_X,	VMAKE,	#VT,	3,	#SC,	#SC,	#SC)
YY("IMPLICIT",	IMPLICIT_X,	RMAKE,	#RT,	2,	#VT,	#SC,	0)
YY("IMPLICIT",	IMPLICIT_X,	TMAKE,	#TR,	2,	#RT,	#VT,	0)
YY("SQRT",	SQRT_X,		FSQRT,	#SC,	1,	#SC,	0,	0)
YY("INT",	INT_X,		FINT,	#SC,	1,	#SC,	0,	0)
YY("SINE",	SINE_X,		FSIN,	#SC,	1,	#SC,	0,	0)
YY("COSINE",	COSINE_X,	FCOS,	#SC,	1,	#SC,	0,	0)
YY("ATAN2",	ATAN2_X,	FATAN2,	#SC,	2,	#SC,	#SC,	0)
YY("ROT",	ROT_X,		RMAKE,	#RT,	2,	#VT,	#SC,	0)
YY("ROT",	ROT_X,		VRMAKE,	#RT,	3,	#VT,	#VT,	#VT)
⊃;

	! counts number of different allowable combinations of operators,
		arguments, and types of arguments, and for each
		computes an integer function ;

REDEFINE XXCOUNT=0;
redefine XX(OP,OP_TYPE,TYPE1,TYPE2,TYPE3,FUNC) = ⊂
	REDEFINE XXCOUNT=XXCOUNT+1;
	REDEFINE XX_VAL=((op_type*#dtype + type1)* #dtype + type2)*#DTYPE*#DTYPE;
	XX_VAL ,⊃;
redefine YY(OP,OP_TYPE,OP_FUNC,OP_DTYPE,#N,#1,#2,#3) = ⊂
	REDEFINE XXCOUNT=XXCOUNT+1;
	REDEFINE XX_VAL=MCOMPUTE_FUNC(op_type,#1,#2,#3,0);
	REDEFINE XX_TEMP=⊂XX_VAL ,⊃;
	XX_TEMP ⊃;


	! array OCODE consists of all the codes defined;

preset_array(OCODE, OPCODE, INTEGER, 1, XXCOUNT);

DEFINE FUNCTION_X=XXCOUNT + 1;

redefine XX(OP,OP_TYPE,TYPE1,TYPE2,TYPE3,FUNC) = ⊂
	TYPE3 , ⊃ ;
redefine YY(OP,OP_TYPE,OP_FUNC,OP_DTYPE,#N,#1,#2,#3) = ⊂
	OP_DTYPE, ⊃;
preset_array(OPTYPE, OPCODE, INTEGER, 1, XXCOUNT);

	! this procedure calls the relevant expression evaluation routine;

RPTR(EXPR) PROCEDURE MAKE_CODE(INTEGER $$$$, NARG; RPTR(EXPR)R1);
α	RPTR(EXPR)R3; INTEGER PP,I; INTEGER ARRAY Q[1:4];
	R3←R1;

	IF $$$$=FUNCTION_X THEN
	α RPTR(FUNCTION,SCALAR,VECTOR,ROT,FRAME,TRANS,EXPR)F;
	F←EXPR:PTR[R1];
	IF NARG≠(pp←FUNCTION:NARGS[F])
		THEN ERROR("function is supposed to have "&cvs(pp)&" arguments, but only has "&cvs(narg)&" arguments");
	IF NARG>0 THEN
	BEGIN
	R3←EXPR:NEXT[R1];
	FOR I←1 STEP 1 UNTIL NARG DO
		BEGIN	RPTR(EXPR)R4;
			PP←EXPR:TYPE[R4←R3];
			IF PP>#DTYPE THEN PP←PP MOD #DTYPE;
			WHILE PP=#EX DO 
				BEGIN R4←EXPR:PTR[R4];
				PP←EXPR:TYPE[R4];
				IF PP>#DTYPE THEN PP←PP MOD #DTYPE;
				END;
			IF PP≠FUNCTION:ARGTYPE[F][I] THEN
				ERROR("Argument "&cvs(I)&" should be type "&
					$DTYPE[FUNCTION:ARGTYPE[F][I]]&
					", not "&$DTYPE[PP]);
			R3←EXPR:NEXT[R3];
		END;
	END;
	R3←MK_EXPR(R1,COMPUTE_FUNC(FUNCTION_X,0,0,0,FUNCTION:TYPE[F]));
	β

	ELSE
	BEGIN
	! expand the arguments from a linked list into an array ;
	FOR I←1 STEP 1 UNTIL NARG MIN 4 DO 
		BEGIN RPTR(EXPR)R4;
			Q[I]←EXPR:TYPE[R4←R3];
			IF Q[I]>#DTYPE THEN Q[I]←Q[I] MOD #DTYPE;
			WHILE Q[I]=#EX
			DO BEGIN R4←EXPR:PTR[R4];
				Q[I]←EXPR:TYPE[R4];
				IF Q[I]>#DTYPE THEN Q[I]←Q[I] MOD #DTYPE;
			END;
			IF Q[I]=#SY THEN Q[I]←EXPR:TYPE[EXPR:PTR[R4]];
		      R3←EXPR:NEXT[R3]; END;
	
	PP←COMPUTE_FUNC($$$$,Q[1],Q[2],Q[3],Q[4]);

	I←MATINX(PP,OCODE,1,XXCOUNT);

	IF I=0
	THEN	ERROR(CODE_OP[$$$$]&" cannot take argument(s) type(s) "&
		$DTYPE[Q[1]]&"  "&$DTYPE[Q[2]]&"  "&$DTYPE[Q[3]]&"  "&$DTYPE[Q[4]])
	ELSE R3←MK_EXPR(R1, COMPUTE_FUNC($$$$,NARG,0,0,OPTYPE[I]));

	END;
return(R3);

β;

RPTR(EXPR) PROCEDURE EVAL_CODE(INTEGER $$$$, NARG; RPTR(EXPR)R1);
α	RPTR(EXPR)R3; INTEGER PP,I; INTEGER ARRAY Q[1:4];
	REAL ARRAY QQ[1:4];
	rptr(scalar,vector,trans,rot,frame) ARRAY rr[1:4];
REDEFINE YY(OP,OP_TYPE,OP_FUNC,OP_DTYPE,#n,#1,#2,#3) = ⊂
	redefine rr1= ⊂ ifc #1=#sc thenc QQ[1] elsec RR[1] ENDC ⊃;
	redefine rr2= ⊂ ifc #2=#sc thenc QQ[2] elsec RR[2] ENDC ⊃;
	redefine rr3= ⊂ ifc #3=#sc thenc QQ[3] elsec RR[3] ENDC ⊃;
	redefine xx_temp = ⊂
			   CASEC #n OFC
	⊂;R3←MK_EPXR(OP_FUNC,OP_DTYPE,NULL_RECORD)⊃,
	⊂;R3←MK_EXPR(OP_FUNC(rr1),OP_DTYPE)⊃,
	⊂;R3←MK_EXPR(OP_FUNC(rr1,rr2),OP_DTYPE)⊃,
	⊂;R3←MK_EXPR(OP_FUNC(rr1,rr2,rr3),OP_DTYPE)⊃,
			   ⊂;REQUIRE " HAH" MESSAGE;⊃ ENDC
			⊃;
	xx_temp ⊃;
REDEFINE XX(OP,OP_TYPE,TYPE1,TYPE2,TYPE3,FUNC) =
	⊂ 	redefine #1 = ⊂ IFC TYPE1=#SC THENC QQ[1] ELSEC rr[1] ENDC ⊃  ;
		redefine #2 = ⊂ IFC TYPE2=#SC THENC QQ[2] ELSEC rr[2] ENDC ⊃ ;
	  redefine xx_temp = ⊂
		IFC (#SC≤TYPE3≤#FR) THENC
			; R3←MK_EXPR(FUNC,TYPE3)
		ELSEC	; REQUIRE " HAH " MESSAGE; ENDC ⊃;
	  xx_temp   ⊃;
	R3←R1;
		! expand the arguments from a linked list into an array ;

	FOR I←1 STEP 1 UNTIL NARG MIN 4 DO 
		BEGIN
		      RR[I]←EXPR:PTR[R3];
		      IF (Q[I]←EXPR:TYPE[R3])=#SC
			 THEN QQ[I]←SCALAR:VALUE[RR[I]]
			 ELSE IF Q[I]>#DTYPE THEN Q[I]←Q[I] MOD #DTYPE;
		      R3←EXPR:NEXT[R3]; END;
	
	PP←COMPUTE_FUNC($$$$,Q[1],Q[2],Q[3],Q[4]);

	I←MATINX(PP,OCODE,1,XXCOUNT);

	CASE I OF
		BEGIN
		ERROR(CODE_OP[$$$$]&" cannot take argument(s) type(s) "&
			$DTYPE[Q[1]]&"  "&$DTYPE[Q[2]]&"  "&$DTYPE[Q[3]]&"  "&$DTYPE[Q[4]])
		OPCODE
		END;

	return(R3);

β;
!	procedures exp,term,factor;

!	E:	{+|-} T {+|- T }

	T:	F {*|/ F}

	F:	( E ), 
		f(  ,  ,  ...)
		<constant>,
		<id>,	;



! EXP	E:	{+|-} T {+|- T }

TERM	T:	F {*|/ F}

FACTOR	F:	( E ) or | E | or func(E,E,E,..) or <constant> or <id> ;


FORWARD RECURSIVE RPTR(EXPR)PROCEDURE TERM;
FORWARD RECURSIVE RPTR(EXPR)PROCEDURE FACTOR;


!	EXP	E:	{+|-} T {+|- T }	;

RECURSIVE RPTR(EXPR) PROCEDURE EXP;
	α	RPTR(EXPR) $$1; INTEGER I;
		IF #TOKEN=OPERATOR_TYPE AND TOKEN_CLASS = #EXP THEN
			α I←TOKEN_INDEX;
			GGTOKEN;	$$1←TERM;
			$$1←MAKE_CODE(I,1,$$1);
			β
			ELSE $$1←TERM;
		WHILE #TOKEN=OPERATOR_TYPE AND TOKEN_CLASS = #EXP DO
			α I←TOKEN_INDEX;
			GGTOKEN; EXPR:NEXT[$$1]←TERM;
			$$1←MAKE_CODE(I,2,$$1);
			β;
		RETURN($$1);
	β;

!	TERM	T:	F {*|/ F}	;

RECURSIVE RPTR(EXPR) PROCEDURE TERM;
	α	RPTR(EXPR) $$1; INTEGER I;
		$$1←FACTOR;
		WHILE  (#TOKEN=OPERATOR_TYPE OR #TOKEN=RES_TYPE) AND TOKEN_CLASS = #TERM DO
			α I←TOKEN_INDEX;
			GGTOKEN; EXPR:NEXT[$$1]←FACTOR;
			$$1←MAKE_CODE(I,2,$$1);
			β;
		RETURN($$1);
	β;

RECURSIVE RPTR(EXPR) PROCEDURE FACTOR;
α	RPTR(EXPR)$$1,$$2,$$3; INTEGER I,I2;
	LABEL FINISH;
	CASE #TOKEN OF
		α	
		[REAL_TYPE]	
		[INT_TYPE]	
			α
			$$1←MK_EXPR(TOKEN_PTR,TOKEN_INDEX);
			GGTOKEN(FALSE);
			β;

		[ID_TYPE]
			BEGIN RPTR(EXPR)$$4;
			$$4←PUSHSYMSTACK(TOKEN_PTR,TOKENINDEX);
			IF FN_CUR≠NULL_RECORD THEN
			α
			INTEGER I;
			FOR I←1 STEP 1 UNTIL FUNCTION:NARGS[FN_CUR]
				DO IF EQU(TOKEN,FUNCTION:ARGNAME[FN_CUR][I])
				THEN
				α
				$$1←MK_EXPR(FUNCTION:PTR[FN_CUR][I],#EX);
				DONE;
				β;
			IF I≤ FUNCTION:NARGS[FN_CUR] THEN 
				α GGTOKEN(FALSE); GOTO FINISH; β
			β;

			IF TOKEN_INDEX = #FN
			THEN    BEGIN INTEGER I3;
				RPTR(FUNCTION) QQ; RPTR(SYMBOL)QQ2;
				QQ←SYMBOL:OBJECT[QQ2←TOKEN_PTR];
				I2 ← FUNCTION:NARGS[QQ] ;
				IF SYMBOL:NUSES[QQ2]>0 THEN
					BEGIN STRING SS,S,SS2; SS2←SS←NULL;
					FOR I3←1 STEP 1 UNTIL SYMBOL:NUSES[QQ2]
					DO IF ¬SYMBOL:VALID[EXPR:PTR[SYMBOL:USES[QQ2][I3]]]
						THEN 
						BEGIN
						INTEGER I4; 
						RPTR(SYMBOL) SY;
						IF(SY←CHECKTOT(S←SYMBOL:PNAME[EXPR:PTR[SYMBOL:USES[QQ2][I3]]],I4))
							=NULL_RECORD
						THEN SS←SS&"  "&S
						ELSE 
						IF I4≠EXPR:TYPE[SYMBOL:USES[QQ2][I3]]
						    THEN SS2←SS2&"  "&S
						    ELSE α EXPR:PTR[SYMBOL:USES[QQ2][I3]]←SY;
							ADDSYMUSED(QQ2,SY);
							β;
						END;
					IF SS≠NULL THEN ERROR("In function "&SYMBOL:PNAME[QQ2]
						&" the following variables are nonexistent:"
						& SS);
					IF SS2≠NULL THEN ERROR("In function "&SYMBOL:PNAME[QQ2]
						&" the following variables are of a different data type than specified"
						& SS2);
					END;
				$$2←$$1←MK_EXPR(QQ, #FN) ;
				I←0;
				IF I2>0 THEN
					α GGTOKEN;I←0;
					IF TOKEN≠"(" THEN
						ERROR("require left paren here");
						DO α
						GGTOKEN;$$3←EXP; I←I+1;
						EXPR:NEXT[$$2]←$$3;
						$$2←$$3;
						β UNTIL TOKEN≠"," ;
					IF TOKEN≠")" THEN ERROR("need right paren here");
					β;
				$$1←MAKE_CODE(FUNCTION_X, I, $$1);
				GGTOKEN(FALSE);
				END
			ELSE
			α
			$$1←MK_EXPR($$4,#SY);
			GGTOKEN(FALSE);
			β;
			END;
		[OPERATOR_TYPE]
			CASE TOKEN_INDEX OF
			α
			[LPAREN_X]
				α GGTOKEN; $$2←$$1←EXP; I2←1;
				IF TOKEN≠")"
				THEN WHILE TOKEN="," DO
					α GGTOKEN; $$3←EXP;
					I2←I2+1;
					$$2←(EXPR:NEXT[$$2]←$$3);
					β;
				IF TOKEN≠")" THEN
					ERROR("MISMATCHED PAREN,WILL INSERT")
					ELSE GGTOKEN(FALSE);
				IF I2≠1 THEN $$1←MAKE_CODE(IMPLICIT_X,I2,$$1);
				β;
			[MAGNITUDE_X]
				α GGTOKEN; $$1←EXP;
				IF TOKEN="|"
				THEN GGTOKEN(FALSE)
				ELSE ERROR("MISMATCHED VERT BAR");
				$$1←MAKE_CODE(MAGNITUDE_X,1,$$1);
				β;
			ELSE	ERROR("UNEXPECTED TOKEN FOUND"&TOKEN)
			β;
		[RES_TYPE]
			IF EQU(TOKEN,"BPARK")
				THEN α $$1←MK_EXPR(F_BPARK,#FR);
					GTOKEN(FALSE);  β     
				ELSE IF EQU(TOKEN,"YPARK")
				THEN α $$1←MK_EXPR(F_YPARK,#FR);
					GTOKEN(FALSE);  β     
			ELSE
			IF TOKEN_INDEX=EVAL_X
			THEN α RPTR(TREE) $TR; STRING S;RPTR(ANY_CLASS)TEMP;
			EXPRESSION_STRING←EXPRESSION_STRING[1 TO ∞-4]&"{ "&TOKEN;
			GGTOKEN;
			IF TOKEN≠"(" THEN ERROR("REQUIRE LEFT PAREN")
			ELSE $TR←GTEXPR;
			$$1←MK_EXPR(TEMP←TREE:DATA[$TR],TREE:DTYPE[$TR]);
				CASE TREE:DTYPE[$TR] OF
				BEGIN "CASE"
				[#SC]  S← CVGX(SCALAR:VALUE[TEMP]);
				[#VT]  S← STR_VT(VECTOR:XC[TEMP],
	  		VECTOR:YC[TEMP],(VECTOR:ZC[TEMP]),8);
				[#RT] S←STR_RT(ROT:XF[TEMP]);
				[#FR] S←"FRAME "&STR_TR(FRAME:XF[TEMP],1,8);
				[#TR] S←STR_TR(TRANS:XF[TEMP],1,8)
				END "CASE";
			GGTOKEN;
			IF TOKEN≠")" THEN ERROR("REQUIRE RIGHT PAREN")
				ELSE
			EXPRESSION_STRING←EXPRESSION_STRING&" = } "&S;
			GGTOKEN(FALSE);
			β
			ELSE
			α I←TOKEN_INDEX; IF TOKEN_CLASS≠#FACTOR
				THEN ERROR(TOKEN&" is not a valid term in an expression");
			GGTOKEN;
			IF TOKEN≠"("
			THEN ERROR("REQUIRE LEFT PAREN, WILL INSERT")
			ELSE GGTOKEN;
			$$2←$$1←EXP; I2←1;
			WHILE TOKEN="," DO
				α GGTOKEN; $$3←EXP;	I2←I2 + 1;
				$$2←(EXPR:NEXT[$$2]←$$3);
				β;
			IF TOKEN≠")"
			    THEN ERROR("MISMATCHED PAREN")
			    ELSE GGTOKEN(FALSE);
			$$1←MAKE_CODE(I,I2,$$1);
			β;

		[UNDECLARED_TYPE]
			IF FN_CUR=NULL_RECORD THEN ERROR("UNEXPECTED TOKEN FOUND")
			ELSE
			α
			INTEGER I;
			FOR I←1 STEP 1 UNTIL FUNCTION:NARGS[FN_CUR]
				DO IF EQU(TOKEN,FUNCTION:ARGNAME[FN_CUR][I])
				THEN
				α
				$$1←MK_EXPR(FUNCTION:PTR[FN_CUR][I],#EX);
				DONE;
				β;
			IF I> FUNCTION:NARGS[FN_CUR] THEN ERROR(TOKEN & " IS UNKNOWN");
			GGTOKEN(FALSE);
			β;

		ELSE	ERROR("UNEXPECTED TOKEN FOUND")
				
		β;

FINISH:	RETURN($$1);
β;
!	function evaluation routines:	EVAL, REDUCE;

FORWARD RECURSIVE RPTR(EXPR) PROCEDURE EVAL(INTEGER NCODE; RPTR(EXPR)F);

RECURSIVE RPTR(EXPR) PROCEDURE REDUCE(RPTR(EXPR)F);
	IF #SC≤EXPR:TYPE[F]≤#FR
	THEN RETURN(MK_EXPR(EXPR:PTR[F],EXPR:TYPE[F]))
	ELSE IF EXPR:TYPE[F]=#EX
		THEN RETURN (EXPR:PTR[F])
		ELSE IF EXPR:TYPE[F]=#SY
		THEN RETURN(MK_EXPR(SYMBOL:OBJECT[EXPR:PTR[EXPR:PTR[F]]],EXPR:TYPE[EXPR:PTR[F]]))
		ELSE RETURN(EVAL(EXPR:TYPE[F],EXPR:PTR[F]));


RECURSIVE RPTR(EXPR)PROCEDURE FNEVAL(RPTR(EXPR)F);
	BEGIN "eval func"  RPTR(EXPR)$1,$2,$3,$4;
	RPTR(FUNCTION,SCALAR,VECTOR,ROT,FRAME,TRANS,EXPR) F1;
	INTEGER #ARGS;
	F1←EXPR:PTR[F]; #ARGS←FUNCTION:NARGS[F1]; $1←F;
		α
		RPTR(EXPR)ARRAY PTR[0:#ARGS];INTEGER I; I←0;
		WHILE $1←EXPR:NEXT[$1]
		DO α
			I←I+1; $4←REDUCE($1);
			ECOPY(PTR[I]←NEW_RECORD(EXPR),FUNCTION:PTR[F1][I]);
			ECOPY(FUNCTION:PTR[F1][I],$4);
		   β;
		IF I≠#ARGS THEN ERROR("EVAL ERROR - ARGS TO FUNCTION WRONG NUMBER");
		$1←REDUCE(FUNCTION:EXPR[F1]);
		IF #ARGS>0 THEN
		FOR I←1 STEP 1 UNTIL #ARGS
			DO ECOPY(FUNCTION:PTR[F1][I],PTR[I]);
		β ;
	RETURN($1);
	END "eval func" ;

RECURSIVE RPTR(EXPR) PROCEDURE EVAL(INTEGER NCODE; RPTR(EXPR) F);
	BEGIN	"EVAL" RPTR(EXPR) $1,$2,$3,$4; INTEGER $$$$,#ARGS;
		$$$$←UNCOMPUTE_FUNC(NCODE,1);
		IF $$$$=FUNCTION_X
		THEN	$1←FNEVAL(F)
		ELSE BEGIN
			$2←$3←REDUCE($1←F);
			WHILE $1←EXPR:NEXT[$1]
			DO α
				$4←REDUCE($1);
				EXPR:NEXT[$3]←$4;
				$3←$4;
			   β;
			#ARGS←UNCOMPUTE_FUNC(NCODE,2);
			$1←EVAL_CODE($$$$,#ARGS,$2);
			END;
		RETURN($1) ;
	END "EVAL";

!	GTEXPR, FNEXPR;

	! returns the final evaluated form;

INTERNAL RECURSIVE RPTR(TREE)PROCEDURE GTEXPR;
	α	RPTR(EXPR)$$1,SAVSYMSTACKTOP;
		FN_CUR←NULL_RECORD;
		SAVSYMSTACKTOP←SYMSTACKTOP;
		SYMSTACKTOP←NULL_RECORD;
		GGTOKEN;
		$$1←EXP;
		STOKEN←TRUE;
		$$1←REDUCE($$1);
		SYMSTACKTOP←SAVSYMSTACKTOP;
		RETURN(NWTREE(EXPR:PTR[$$1],EXPR:TYPE[$$1]));
	β;


	! returns the internal form ;

INTERNAL RPTR(TREE)PROCEDURE FNEXPR(RPTR(FUNCTION)F;REFERENCE STRING FBODY;
		REFERENCE RPTR(EXPR) SYMUSED);
	α	RPTR(EXPR)$$1;
		EXPRESSION_STRING←NULL;
		FN_CUR←F;
		GGTOKEN;
		SYMSTACKTOP←NULL_RECORD;
		$$1←EXP;
		STOKEN←TRUE;
		FBODY←EXPRESSION_STRING[1 TO ∞ - 1];
		SYMUSED←SYMSTACKTOP;
		RETURN(NWTREE(EXPR:PTR[$$1],EXPR:TYPE[$$1]));
	β;

END;